Shareware Grab Bag/Shareware Grab Bag.iso/005/tsrcom16.arc/MAPMEM.PAS

Pascal/Delphi Source File | 1986-03-24 | 18.0 KB | 575 lines

{**************************************************************************
*   Maps system memory blocks for MS/PCDOS 2.0 and higher.                *
*   Also maps expanded memory allocation blocks                           *
*   Copyright (c) 1986 Kim Kokkonen, TurboPower Software.                 *
*   Released to the public domain for personal, non-commercial use only.  *
***************************************************************************
*   written 1/2/86                                                        *
*   revised 1/10/86 for                                                   *
*     running under DOS 2.X, where block owner names are unknown          *
*   revised 1/22/86 for                                                   *
*     a bug in parsing the owner name of the block                        *
*     a quirk in the way that the DOS PRINT buffer installs itself        *
*     minor cosmetic changes                                              *
*   revised 2/6/86 for (version 1.3)                                      *
*     smarter filtering for processes that deallocate their environment   *
*   revised 2/23/86 for (version 1.4)                                     *
*     add a map of Expanded memory (EMS) as well                          *
*   revised 2/26/86 for (version 1.5)                                     *
*     change format of last memory block                                  *
*     change to more reliable scheme of finding first block               *
*       (thanks to Chris Dunford for pointing out a useful                *
*        undocumented DOS function).                                      *
*     support environment lengths up to 32K                               *
*   revised 3/8/86 for (version 1.6)                                      *
*     support "verbose" output mode                                       *
*       display open file handles                                         *
*       show command line of each block                                   *
***************************************************************************
*   telephone: [phone], CompuServe: 72457,2131.                      *
*   requires Turbo version 3 to compile.                                  *
*   Compile with mAx dynamic memory = FFFF.                               *
***************************************************************************}

{$P128}

PROGRAM MapMem;
  {-look at the system memory map using DOS memory control blocks}
CONST
  Version = '1.6';
  MaxBlocks = 100;            {max number of DOS memory blocks checked}
  MaxVector = $FF;            {highest interrupt vector checked for trapping}
TYPE
  Block =
  RECORD                      {store info about each memory block as it is found}
    idbyte : Byte;
    mcb : Integer;
    psp : Integer;
    len : Integer;
    psplen : Integer;
    env : Integer;
    cnt : Integer;
  END;
  BlockType = 0..MaxBlocks;
  BlockArray = ARRAY[BlockType] OF Block;
  Pathname = STRING[64];
  registers =
  RECORD
    CASE Integer OF
      1 : (ax, bx, cx, dx, bp, si, di, ds, es, flags : Integer);
      2 : (al, ah, bl, bh, cl, ch, dl, dh : Byte);
  END;

VAR
  Blocks : BlockArray;
  BlockNum : BlockType;
  verbose : Boolean;

  PROCEDURE StripNonAscii(VAR t : Pathname);
    {-return an empty string if t contains any non-printable characters}
  VAR
    ipos : Byte;
    goodname : Boolean;
  BEGIN
    goodname := True;
    FOR ipos := 1 TO Length(t) DO
      IF (t[ipos] < ' ') OR (t[ipos] > '}') THEN
        goodname := False;
    IF NOT(goodname) THEN t := '';
  END {stripnonascii} ;

  PROCEDURE FindTheBlocks;
    {-scan memory for the allocated memory blocks}
  CONST
    MidBlockID = $4D;         {byte DOS uses to identify part of MCB chain}
    EndBlockID = $5A;         {byte DOS uses to identify last block of MCB chain}
  VAR
    mcbSeg : Integer;         {segment address of current MCB}
    nextSeg : Integer;        {computed segment address for the next MCB}
    gotFirst : Boolean;       {true after first MCB is found}
    gotLast : Boolean;        {true after last MCB is found}
    idbyte : Byte;            {byte that DOS uses to identify an MCB}

    FUNCTION GetStartMCB : Integer;
      {-return the first MCB segment}
    VAR
      reg : registers;
    BEGIN
      reg.ah := $52;
      MsDos(reg);
      GetStartMCB := MemW[reg.es:(reg.bx-2)];
    END {getstartmcb} ;

    PROCEDURE StoreTheBlock(VAR mcbSeg, nextSeg : Integer;
                            VAR gotFirst, gotLast : Boolean);
      {-store information regarding the memory block}
    VAR
      nextID : Byte;
      pspAdd : Integer;       {segment address of the current PSP}
      mcbLen : Integer;       {size of the current memory block in paragraphs}

    BEGIN

      mcbLen := MemW[mcbSeg:3]; {size of the MCB in paragraphs}
      nextSeg := Succ(mcbSeg+mcbLen); {where the next MCB should be}
      pspAdd := MemW[mcbSeg:1]; {address of program segment prefix for MCB}
      nextID := Mem[nextSeg:0];

      IF gotLast OR (nextID = EndBlockID) OR (nextID = MidBlockID) THEN BEGIN
        BlockNum := Succ(BlockNum);
        gotFirst := True;
        WITH Blocks[BlockNum] DO BEGIN
          idbyte := Mem[mcbSeg:0];
          mcb := mcbSeg;
          psp := pspAdd;
          env := MemW[pspAdd:$2C];
          len := mcbLen;
          psplen := 0;
          cnt := 1;
        END;
      END;

    END {storetheblock} ;

  BEGIN

    {initialize}
    mcbSeg := GetStartMCB;
    gotFirst := False;
    gotLast := False;
    BlockNum := 0;

    {scan all memory until the last block is found}
    REPEAT
      idbyte := Mem[mcbSeg:0];
      IF idbyte = MidBlockID THEN BEGIN
        StoreTheBlock(mcbSeg, nextSeg, gotFirst, gotLast);
        IF gotFirst THEN mcbSeg := nextSeg ELSE mcbSeg := Succ(mcbSeg);
      END ELSE IF gotFirst AND (idbyte = EndBlockID) THEN BEGIN
        gotLast := True;
        StoreTheBlock(mcbSeg, nextSeg, gotFirst, gotLast);
      END ELSE BEGIN
        {start block was invalid}
        WriteLn('corrupted allocation chain or program error');
        Halt(1);
      END;
    UNTIL gotLast;

  END {findtheblocks} ;

  FUNCTION Cardinal(i : Integer) : Real;
    {-return an unsigned integer 0..65535}
  BEGIN
    Cardinal := 256.0*Hi(i)+Lo(i);
  END {cardinal} ;

  PROCEDURE ShowTheBlocks;
    {-analyze and display the blocks found}
  TYPE
    HexString = STRING[4];
    Address = RECORD
                offset, segment : Integer;
              END;
    VectorType = 0..MaxVector;
  VAR
    st : Pathname;
    b : BlockType;
    StLen, DOSv : Byte;
    Vectors : ARRAY[VectorType] OF Address ABSOLUTE 0 : 0;
    Vtable : ARRAY[VectorType] OF Real;
    SumNum : BlockType;
    Sum : BlockArray;

    FUNCTION Hex(i : Integer) : HexString;
      {-return hex representation of integer}
    CONST
      hc : ARRAY[0..15] OF Char = '0123456789ABCDEF';
    VAR
      l, h : Byte;
    BEGIN
      l := Lo(i); h := Hi(i);
      Hex := hc[h SHR 4]+hc[h AND $F]+hc[l SHR 4]+hc[l AND $F];
    END {hex} ;

    FUNCTION DOSversion : Byte;
      {-return the major version number of DOS}
    VAR
      reg : registers;
    BEGIN
      reg.ah := $30;
      MsDos(reg);
      DOSversion := reg.al;
    END {dosversion} ;

    FUNCTION Owner(startadd : Integer) : Pathname;
      {-return the name of the owner program of an MCB}
    TYPE
      chararray = ARRAY[0..32767] OF Char;
    VAR
      e : ^chararray;
      i : Integer;
      t : Pathname;

      FUNCTION LongPos(m : Pathname; VAR s : chararray) : Integer;
        {-return the position number of m in s, or 0 if not found}
      VAR
        mc : Char;
        ss : Pathname;
        i, maxindex : Integer;
        found : Boolean;
      BEGIN
        i := 0;
        maxindex := SizeOf(s)-Length(m);
        ss[0] := m[0];
        IF Length(m) > 0 THEN BEGIN
          mc := m[1];
          REPEAT
            WHILE (s[i] <> mc) AND (i <= maxindex) DO
              i := Succ(i);
            IF s[i] = mc THEN BEGIN
              Move(s[i], ss[1], Length(m));
              found := (ss = m);
              IF NOT(found) THEN i := Succ(i);
            END;
          UNTIL found OR (i > maxindex);
          IF NOT(found) THEN i := 0;
        END;
        LongPos := i;
      END {longpos} ;

      PROCEDURE StripPathname(VAR pname : Pathname);
        {-remove leading drive or path name from the input}
      VAR
        spos, cpos, rpos : Byte;
      BEGIN
        spos := Pos('\', pname);
        cpos := Pos(':', pname);
        IF spos+cpos = 0 THEN Exit;
        IF spos <> 0 THEN BEGIN
          {find the last slash in the pathname}
          rpos := Length(pname);
          WHILE (rpos > 0) AND (pname[rpos] <> '\') DO rpos := Pred(rpos);
        END ELSE
          rpos := cpos;
        Delete(pname, 1, rpos);
      END {strippathname} ;

      PROCEDURE StripExtension(VAR pname : Pathname);
        {-remove the file extension}
      VAR
        dotpos : Byte;
      BEGIN
        dotpos := Pos('.', pname);
        IF dotpos <> 0 THEN
          Delete(pname, dotpos, 64);
      END {stripextension} ;

    BEGIN
      {point to the environment string}
      e := Ptr(startadd, 0);

      {find end of the standard environment}
      i := LongPos(#0#0, e^);
      IF i = 0 THEN BEGIN
        {something's wrong, exit gracefully}
        Owner := '';
        Exit;
      END;

      {end of environment found, get the program name that follows it}
      t := '';
      i := i+4;               {skip over #0#0#args}
      REPEAT
        t := t+e^[i];
        i := Succ(i);
      UNTIL (Length(t) > 64) OR (e^[i] = #0);

      StripNonAscii(t);
      IF t = '' THEN
        Owner := 'N/A'
      ELSE BEGIN
        StripPathname(t);
        StripExtension(t);
        IF t = '' THEN t := 'N/A';
        Owner := t;
      END;

    END {owner} ;

    PROCEDURE InitVectorTable;
      {-build real equivalent of vector addresses}
    VAR
      v : VectorType;

      FUNCTION RealAdd(a : Address) : Real;
        {-return the real equivalent of an address (pointer)}
      BEGIN
        WITH a DO
          RealAdd := 16.0*Cardinal(segment)+Cardinal(offset);
      END {realadd} ;

    BEGIN
      FOR v := 0 TO MaxVector DO
        Vtable[v] := RealAdd(Vectors[v]);
    END {initvectortable} ;

    PROCEDURE WriteHooks(start, stop : Integer);
      {-show the trapped interrupt vectors}
    VAR
      v : VectorType;
      sadd, eadd : Real;
    BEGIN
      sadd := 16.0*Cardinal(start);
      eadd := 16.0*Cardinal(stop);
      FOR v := 0 TO MaxVector DO BEGIN
        IF (Vtable[v] >= sadd) AND (Vtable[v] <= eadd) THEN
          Write(Copy(Hex(v), 3, 2), ' ');
      END;
    END {writehooks} ;

    PROCEDURE SortByPSP(VAR Blocks : BlockArray; BlockNum : BlockType);
      {-sort in order of ascending PSP}
    VAR
      i, j : BlockType;
      temp : Block;
    BEGIN
      FOR i := 1 TO Pred(BlockNum) DO
        FOR j := BlockNum DOWNTO Succ(i) DO
          IF Cardinal(Blocks[j].psp) < Cardinal(Blocks[Pred(j)].psp) THEN BEGIN
            temp := Blocks[j];
            Blocks[j] := Blocks[Pred(j)];
            Blocks[Pred(j)] := temp;
          END;
    END {SortByPSP} ;

    PROCEDURE SumTheBlocks(VAR Blocks : BlockArray;
                           BlockNum : BlockType;
                           VAR Sum : BlockArray;
                           VAR SumNum : BlockType);
      {-combine the blocks with equivalent PSPs}
    VAR
      prevPSP : Integer;
      b : BlockType;
    BEGIN
      SumNum := 0;
      prevPSP := 0;
      FOR b := 1 TO BlockNum DO BEGIN
        IF Blocks[b].psp <> prevPSP THEN BEGIN
          SumNum := Succ(SumNum);
          Sum[SumNum] := Blocks[b];
          prevPSP := Blocks[b].psp;
          IF prevPSP = CSeg THEN
            {don't include the environment as part of free block's length}
            Sum[SumNum].len := 0;
        END ELSE
          WITH Sum[SumNum] DO BEGIN
            cnt := Succ(cnt);
            len := len+Blocks[b].len;
          END;
        {get length of the block which owns the executable program}
        {for checking vector trapping next}
        IF Succ(Blocks[b].mcb) = Blocks[b].psp THEN
          Sum[SumNum].psplen := Blocks[b].len;
      END;
    END {sumblocks} ;

    FUNCTION OpenHandles(psp : Integer) : Integer;
      {-return the number of open handles owned by a process}
    VAR
      h, o : Integer;
      b : Byte;
    BEGIN
      h := 0;
      IF psp <> 8 THEN
        FOR o := 0 TO 19 DO BEGIN
          b := Mem[psp:$18+o];
          IF NOT(b IN [$FF, 0..5]) THEN
            h := Succ(h);
        END;
      OpenHandles := h;
    END {openhandles} ;

    FUNCTION CommandLine(psp : Integer) : Pathname;
      {-return the command line of the PSP}
    VAR
      t : Pathname;
    BEGIN
      IF psp <> 8 THEN BEGIN
        Move(Mem[psp:$80], t, 65);
        StripNonASCII(t);
        IF t[0] > #64 THEN t[0] := #64;
        WHILE (Length(t) > 0) AND (t[1] = #32) DO Delete(t, 1, 1)
      END ELSE
        t := '';
      CommandLine := t;
    END;

  BEGIN
    WriteLn;
    Write('Allocated Memory Map - by TurboPower Software - Version ', Version);

    IF verbose THEN BEGIN
      WriteLn('  (verbose)');
      WriteLn;
      WriteLn(' PSP   MCB  files bytes  owner    command line  hooked vectors');
      WriteLn('----- ----- ----- ------ -------- ------------- -----------------------------');
    END ELSE BEGIN
      WriteLn;
      WriteLn;
      WriteLn('  PSP   bytes  owner    command line        hooked vectors');
      WriteLn('------- ------ -------- ------------------- ------------------------------');
    END;

    DOSv := DOSversion;
    InitVectorTable;
    SortByPSP(Blocks, BlockNum);
    SumTheBlocks(Blocks, BlockNum, Sum, SumNum);

    FOR b := 1 TO SumNum DO WITH Sum[b] DO BEGIN

      Write(' ', Hex(psp), '  ');        {PSP address}
      IF verbose THEN BEGIN
        Write(Hex(mcb), '  ',       {MCB address}
        OpenHandles(psp):2, '  '); {number of open file handles}
      END;
      Write(16.0*Cardinal(len):6:0, '  '); {size of block in bytes}

      {get the program owning this block by scanning the environment}
      IF b = SumNum THEN
        st := 'free'
      ELSE IF (DOSv >= 3) AND (cnt > 1) THEN
        st := Owner(env)
      ELSE
        st := 'N/A';
      WHILE Length(st) < 9 DO st := st+' ';
      Write(st);

      {write the command line that invoked the program}
      IF b = SumNum THEN
        st := ''
      ELSE
        st := CommandLine(psp);
      IF verbose THEN
        StLen := 13
      ELSE
        StLen := 19;
      IF Length(st) > StLen-3 THEN
        st := Copy(st, 1, StLen-3)+'...'
      ELSE
        WHILE Length(st) < StLen DO st := st+' ';
      Write(st, ' ');

      {write the trapped interrupt vectors}
      IF b <> SumNum THEN WriteHooks(psp, psp+psplen);

      WriteLn;
    END;

  END {showtheblocks} ;

  PROCEDURE ShowTheEMSblocks;
    {-map out expanded memory, if present}
  CONST
    EMSinterrupt = $67;       {the vector used by the expanded memory manager}
    MaxHandles = 255;

  TYPE
    HandlePageRecord =
    RECORD
      handle : Integer;
      numpages : Integer;
    END;

    PageArray = ARRAY[0..MaxHandles] OF HandlePageRecord;
    PageArrayPtr = ^PageArray;

  VAR
    EMSregs : registers;
    EMShandles : Integer;
    Map : PageArrayPtr;
    TotalPages : Integer;

    FUNCTION EMSpresent : Boolean;
      {-return true if EMS memory manager is present}
    VAR
      f : FILE;
    BEGIN
      {"file handle" defined by the expanded memory manager at installation}
      Assign(f, 'EMMXXXX0');
      {$I-} Reset(f) {$I+} ;
      EMSpresent := (IOResult = 0);
      Close(f);
    END {EMSpresent} ;

    FUNCTION EMSpagesAvailable(VAR TotalPages : Integer) : Integer;
      {-return the number of 16K expanded memory pages available and unallocated}
    BEGIN
      EMSregs.ah := $42;
      Intr(EMSinterrupt, EMSregs);
      IF EMSregs.ah <> 0 THEN BEGIN
        WriteLn('EMS device not responding');
        EMSpagesAvailable := 0;
        Exit;
      END;
      EMSpagesAvailable := EMSregs.bx;
      TotalPages := EMSregs.dx;
    END {EMSpagesAvailable} ;

    FUNCTION EMShandlesActive : Integer;
      {-return the number of active EMS handles}
    BEGIN
      EMSregs.ah := $4B;
      Intr(EMSinterrupt, EMSregs);
      IF EMSregs.ah <> 0 THEN BEGIN
        WriteLn('EMS device not responding');
        EMShandlesActive := 0;
        Exit;
      END;
      EMShandlesActive := EMSregs.bx;
    END {EMShandlesActive} ;

    PROCEDURE EMSpageMap(VAR PageMap : PageArray);
      {-return an array of the allocated memory blocks}
    BEGIN
      EMSregs.ah := $4D;
      EMSregs.es := Seg(PageMap);
      EMSregs.di := Ofs(PageMap);
      EMSregs.bx := 0;
      Intr(EMSinterrupt, EMSregs);
      IF EMSregs.ah <> 0 THEN
        WriteLn('EMS device not responding');
    END {EMSpageMap} ;

    PROCEDURE WriteEMSmap(PageMap : PageArray; handles : Integer);
      {-write out the EMS page map}
    VAR
      h : Integer;
    BEGIN
      WriteLn('block   bytes   (Expanded Memory)');
      WriteLn('-----   ------');
      FOR h := 0 TO Pred(handles) DO WITH PageMap[h] DO
        WriteLn(h:5, '  ', (16384.0*Cardinal(numpages)):7:0);
    END {writeEMSmap} ;

  BEGIN
    IF NOT(EMSpresent) THEN Exit;
    EMShandles := EMShandlesActive;
    WriteLn;
    GetMem(Map, 4*EMShandles);
    EMSpageMap(Map^);
    WriteEMSmap(Map^, EMShandles);
    WriteLn(' free  ', (16384.0*Cardinal(EMSpagesAvailable(TotalPages))):7:0);
    WriteLn('total  ', (16384.0*Cardinal(TotalPages)):7:0);
  END {showtheemsblocks} ;


BEGIN
  verbose := False;
  IF ParamCount > 0 THEN
    IF (ParamStr(1) = 'V') OR (ParamStr(1) = 'v') THEN
      verbose := True;
  FindTheBlocks;
  ShowTheBlocks;
  ShowTheEMSblocks;
END.